
package Sgdb::Cntr::UsageLookup ;
use Sgdb::Utils qw( :DEFAULT
                    bind_search_mechanism
                    bind_history_mechanism
                    localconfig
                    ) ;

# pragmas for all
use warnings ;
use strict ;
use integer ;
use bytes ;

# Note: no globals allowed here for future multi interface option

init() ;

sub init { 1 }

sub new {

    my $self = shift or die "whoami" ;
    my $topf = shift or die "top frame needed" ;

    my $text = ( pref ('usage-lookup-show-scrollbars') ?
                 $topf -> Scrolled ( 'ROText', pref 'usage-lookup-text' ) :
                 $topf ->             ROText ( pref 'usage-lookup-text' ) ) ;

    balloonset $text =><<DoC ;
find callers of function
DoC

    pref_tags $text, 'usage-lookup', qw/title lookup code/ ;
    $text -> tagBind ( 'lookup', '<1>', [\&info_line, $text] ) ;
    $text -> tagBind ( 'lookup', '<Enter>', [$text, 'configure', -cursor, 'arrow'] ) ;
    $text -> tagBind ( 'lookup', '<Leave>', [$text, 'configure', -cursor, 'xterm'] ) ;

    { # menu
        my $m = $text -> menu() ;
        $m -> delete( 0 ) ;
        $m -> add ( 'separator' ) ;
        $m -> add ( 'command', -label => 'clear', -command => [$text, 'delete', '1.0', 'end']) ;
        $m -> add ( 'separator' ) ;
        $m -> add ( 'command', -label => 'close', -command => [\&hook_run, 'close-current-data-pane']) ;
    }

    $text -> bind ("<Meta-Up>"   =>  sub {}) ;
    $text -> bind ("<Meta-Down>" =>  sub {}) ;

    my $lookup ;
    my $e = $topf -> Entry ( -textvariable => \$lookup,
                             pref 'usage-lookup-entry'
                             ) -> pack ( -side => 'top',
                                         -fill => 'x',
                                         -anchor => 'sw',
                                         ) ;


    balloonset $e => <<DoC ;
type in function name then press
'Retrun' to find it's callers
DoC

    my $hcb = bind_history_mechanism ( $e, \$lookup ) ;

    $e -> bind ("<Return>" => [\&symbol_lookup,     $text, $hcb, \$lookup]) ;
    hook_add 'usage-lookup',  [\&symbol_lookup, $e, $text, $hcb          ]  ;
    # algo: mmm..., too compicated

    bind_search_mechanism  $text, $e  ;

    pref_reconfigure ( 'usage-lookup-text' => $text ,
                       'usage-lookup-entry' => $e
                       ) ;

    $e -> focus ()  ;

    $text ;
}

sub symbol_lookup {

    my ($symfile, $objdump) ;

    return telthemloud 'No Active Debugger' unless            gdb_cached 'is-alive' ;
    return telthemloud 'No Symbol File'     unless $symfile = gdb_cached 'file' ;
    return telthemloud 'No objdump file'    unless $objdump = localconfig 'objdump' ;

    my ($e, $t, $hcb, $ref ) = @_ ;
    my $sym ;

    if (ref $ref ) { $sym = $$ref ; $$ref = '' }
    else           { $sym =  $ref || '' }

    $sym =~ s/^\s+// ;
    $sym =~ s/\s+$// ;
    $sym or return   ;
    $hcb -> ( $sym ) ;

    my ($val, $func) ;
    my $addr = gdb_exec_quiet "info addr $sym" ;

    unless ( $addr =~ /is a function/ ) {
        return telthemloud "'$sym': not a valid function","(not supporting variables, yet)" ;
    }
    telthem "looking for '$sym' callers (it might take a while ..)" ;

    busy ;
    my $qr = qr/\<\s*$sym\s*\>\s*$/ ;
    my $sec =  $symfile =~ /\/\w\d\d\w(?:_\d\d\d\d_\d\d\d)?\.elf/ ? "-j cs" : '' ;
    my $command = "$objdump -d $sec $symfile" ;
#     telme $command ;
    open FILE, "$command | " or return unbusy() & telthemloud "can't execute objdump: $!"  ;
    my @lines ;
    my $count = 0 ;
    while (my $line = <FILE>) {
        next unless $line =~ $qr ;
        push @lines, $line ;
        ++$count < 500 and next ;
        push @lines, "** TO MANY MATCHES **\n" ;
        last ;
    }

    close FILE ;
    $t -> insert ('1.0' ,
                  "usage of $sym ($count matches found):\n" => 'title',
                  map { /^( *[\da-fA-F]+)(.*)/ ?
                          parse_line($2, $1) :
#                           ( $1, 'lookup', $2 . "\n", 'regtext' ) :
                            ( $_, 'regtext' ) } @lines, "\n"
                 ) ;
    unbusy ;
}

sub get_func_info($) {
    my $addr = shift;
    $addr =~ /(?:0x)?([\da-fA-F]+)/ or return ($addr);
    $addr = "0x$1" ;
    my $il = gdb_exec_quiet("info line *$addr");
    ($addr, $il =~ /\<(\w+)(?:\+\d+)?\>/ , $il =~ /(\".*\")/ )
}

sub parse_line {
    my ($line, $addr, $func, $file) = (shift , get_func_info shift ) ;
    ( $addr       , 'lookup', ':', 'regtext',
     ($func || ''), 'lookup', ' ', 'regtext',
     ($file || ''), 'regtext', " ::$line\n", 'regtext')
}

sub info_line {
    busy ;
    my $t = shift ;
    my $c = $t -> index ( 'current' ) ;
    my $add = $t -> get ("$c wordstart" => "$c wordend" ) ;
    $add = "*$add" if $add =~ /^0x/ ;
    gdb_exec "i line $add" ;
    unbusy ;
}


